Model Comparisons

RSA functionality

# speaker informativity
# ---------------------
speaker.inf = function(d, alpha, cost = 0) {
  exp(alpha*(log(d) - cost))
}
# speaker likelihood
# ------------------
speaker.lhd = function(rating, degree, m, alpha) {
  numerator = speaker.inf(m[rating, degree], alpha)
  normalize = sum(sapply(m[rating, ], function(i) {speaker.inf(i, alpha)}))
  return(numerator / normalize)
}
# non-normalized posterior
# -----------------------
nn.post = function(rating, degree, m, alpha, useprior) {
  prior = priors[rating, "prior.p"]
  return(speaker.lhd(rating, degree, m, alpha) * prior)
}
# normalized posterior
# --------------------
norm.post = function(rating, degree, m, alpha, useprior) {
  nn = nn.post(rating, degree, m, alpha, useprior)
  normalize = sum(unlist(sapply(seq(1, 5), function(i){nn.post(i, degree, m, alpha, useprior)})))
  return(nn / normalize)
}

Run model functionality

# run.partial()
# ------------
# Run RSA with model1 (entailment) and model2 (entailment + generic)
run.partial = function(d, alpha=1, useprior=F, usenone=F, normalize=F) {
  if (normalize) {
    mat = d %>%
      select(stars, degree, speaker.p) %>%
      spread(degree, speaker.p) %>%
      mutate(hi = hi / sum(hi),
             low = low / sum(low)) %>%
      select(hi, low)
  } else {
    mat = d %>%
      select(stars, degree, speaker.p) %>%
      spread(degree, speaker.p) %>%
      select(hi, low)
  }
  
  if (usenone) {
    mat$none = c(1, 0, 0, 0, 0)
  } 
  
  d$pred = round(as.numeric(mapply(norm.post, d$stars, d$degree, 
                                    MoreArgs = list(m = mat, 
                                                    alpha = alpha, 
                                                    useprior = useprior))), 
                  digits=4)
  
  return(d)
}

# run.full()
# ------------
# Run RSA with model3 (full) with alternatives
run.full = function(d, alpha=1, useprior=F, usenone=F, addMid=F, normalize=F) {
  # alpha = scales.entropy[scales.entropy$scale==d$scale[1], ]$Entropy
  if (addMid) {
    if (normalize) {
      mat = d %>%
        select(stars, degree, speaker.p) %>%
        spread(degree, speaker.p) %>%
        mutate(hi1 = hi1 / sum(hi1),
               hi2 = hi2 / sum(hi2),
               mid = mid / sum(mid),
               low1 = low1 / sum(low1),
               low2 = low2 / sum(low2)) %>%
        select(hi1, hi2, mid, low1, low2)    
    } else {
      mat = d %>%
        select(stars, degree, speaker.p) %>%
        spread(degree, speaker.p) %>%
        select(hi1, hi2, mid, low1, low2)    
    }
  } else {
    if (normalize) {
      mat = d %>%
        select(stars, degree, speaker.p) %>%
        spread(degree, speaker.p) %>%
        mutate(hi1 = hi1 / sum(hi1),
               hi2 = hi2 / sum(hi2),
               low1 = low1 / sum(low1),
               low2 = low2 / sum(low2)) %>%
        select(hi1, hi2, low1, low2)
    } else {
      mat = d %>%
        select(stars, degree, speaker.p) %>%
        spread(degree, speaker.p) %>%
        select(hi1, hi2, low1, low2)
    }
  }
  
  if (usenone) {
    mat$none = c(1, 0, 0, 0, 0)
  } 
  
  d$pred = round(as.numeric(mapply(norm.post, d$stars, d$degree, 
                                    MoreArgs = list(m = mat, 
                                                    alpha = alpha, 
                                                    useprior = useprior))), 
                  digits=4)
  
  return(d)
}

Tune hyperparams

# tune.alhpa()
# ------------
# d        --> data
# alphas   --> range of alphas to test
# type     --> full or partial model
# useprior --> use uniform prior
# usenone  --> use gener None
tune.alpha = function(d, alphas = seq(from=1, to=10),
                      type="partial", useprior = T,
                      usenone=F, compare.data=NULL, addMid = F, normalize=F) {
  # Tune best alphas
  fit = sapply(alphas, FUN=function(n) {
    if (type == "partial") {
      md = d %>%
        do(run.partial(., alpha=n, useprior=useprior, usenone=usenone, normalize=normalize))
    } else {
      md = d %>%
        do(run.full(., alpha=n, useprior=useprior, usenone=usenone, addMid=addMid, normalize=normalize))
    }
    # Toggle fit to e6 data
    if (!is.null(compare.data)) {
      
      # If we're using e11 data with multiple scalars
      if ("hi1" %in% md$degree) {
        matched.items = which((md[, "scale"] != "some_all" &
                                 (md[, "degree"] == "hi2" | md[, "degree"] == "hi1")) |
                                (md[, "scale"] == "some_all" &
                                   (md[, "degree"] == "hi1" | md[, "degree"] == "low1")))
        md = md[matched.items, ]
        md$degree = ifelse(md$degree == "hi1", "hi", "low")
        stopifnot("listener.p" %in% colnames(compare.data))
      }
      md$listener.p = compare.data$listener.p
    }
    
    # MSE
    return(mean((md$pred - md$listener.p)^2))
  })  
  # get lowest MSE
  best.alpha = which(fit == min(fit))
  return(best.alpha)
}

# Uniform priors
unif.priors = data.frame(stars = seq(1, 5), prior.p = rep(0.2, 5))
emp.priors = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/emp_priors.csv")
priors = unif.priors

scales.entropy = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/scales_entropy.csv")

Model Comparisons

Data for entailment models

speaker = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L0_e8.csv")
listener = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L1_e6.csv")
# Combine speaker / listener
data.partial = left_join(speaker, listener) %>%
  left_join(priors) %>%
  rowwise %>%
  select(scale, degree, stars, speaker.p, listener.p, prior.p) %>%
  mutate(listener.p = ifelse(is.na(listener.p), 0, listener.p)) %>%
  group_by(scale)

Data for full model - no alternatives

speaker = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L0_e10.csv")
listener = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L1_e11.csv")
data.full = left_join(speaker, listener) %>%
  left_join(priors) %>%
  rowwise %>%
  select(scale, degree, stars, speaker.p, listener.p, prior.p) %>%
  mutate(listener.p = ifelse(is.na(listener.p), 0, listener.p)) %>%
  group_by(scale)

Data for full model - alternatives

speaker = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L0_e10a.csv")
data.full.extras = left_join(speaker, listener) %>%
  left_join(priors) %>%
  rowwise %>%
  select(scale, degree, stars, speaker.p, listener.p, prior.p) %>%
  mutate(listener.p = ifelse(is.na(listener.p), 0, listener.p)) %>%
  group_by(scale)

## Joining by: c("scale", "degree", "stars")

## Warning in left_join_impl(x, y, by$x, by$y): joining factors with different
## levels, coercing to character vector

## Joining by: "stars"

## Warning: Grouping rowwise data frame strips rowwise nature

Match items between studies (full and partial)

matched.items = which((data.full[, "scale"] != "some_all" &
        (data.full[, "degree"] == "hi2" | data.full[, "degree"] == "hi1")) |
       (data.full[, "scale"] == "some_all" &
          (data.full[, "degree"] == "hi1" | data.full[, "degree"] == "low1")))
matched.items.extras = which((data.full.extras[, "scale"] != "some_all" &
        (data.full.extras[, "degree"] == "hi2" | data.full.extras[, "degree"] == "hi1")) |
       (data.full.extras[, "scale"] == "some_all" &
          (data.full.extras[, "degree"] == "hi1" | data.full.extras[, "degree"] == "low1")))

Run comparisons

# Save performance output
performance.output = data.frame(model=rep(NA, 16),
                                cor.e6=rep(NA, 16),
                                cor.e11=rep(NA, 16),
                                normalized=rep(NA, 16))
alphas = rep(NA, 16)
data.full.transfer = data.full[matched.items, ]
data.full.transfer$degree =
  ifelse(data.full.transfer$degree == "hi1", "hi", "low")
# Model 1 - Entailment only models
# --------------------------------
# 1.a)
# Entailment only
# Normalized = T
# alpha tuning = F
alphas[1] = 1
m1.a = data.partial %>%
  do(run.partial(., alpha = alphas[1], useprior=T, usenone=F, normalize=T))
# Store output and add e11
m1.a = cbind(m1.a, data.full.transfer$listener.p)
colnames(m1.a)[8] = "e11.listener.p"
performance.output[1, ] = c("m1.a", round(cor(m1.a$listener.p, m1.a$pred), 5),
                            round(cor(m1.a$e11.listener.p, m1.a$pred), 5), T)
# Store plot
m1.a.plot = qplot(stars, listener.p, col=degree, 
      data=m1.a,
      main=paste("m1.a\nalpha: ", alphas[1],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[1, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 1.b)
# Entailment only
# Normalized = F
# alpha tune = F
alphas[2] = 1
m1.b = data.partial %>%
  do(run.partial(., alpha = alphas[1], useprior=T, usenone=F, normalize=F))
# Store output
m1.b = cbind(m1.b, data.full.transfer$listener.p)
colnames(m1.b)[8] = "e11.listener.p"
performance.output[2, ] = c("m1.b", round(cor(m1.b$listener.p, m1.b$pred), 5),
                            round(cor(m1.b$e11.listener.p, m1.b$pred), 5), F)
# Store plot
m1.b.plot = qplot(stars, listener.p, col=degree, 
      data=m1.b,
      main=paste("m1.b\nalpha: ", alphas[2],
                 "\nNormalized = ", F,
                 "\nCorr = ", performance.output[2, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 1.c)
# Entailment only
# Normalized = T
# alpha tune = T
alphas[3] = tune.alpha(data.partial, normalize=T, compare.data=data.full.transfer)
m1.c = data.partial %>%
  do(run.partial(., alpha = alphas[3], useprior=T, usenone=F, normalize=T))
# Store output
m1.c = cbind(m1.c, data.full.transfer$listener.p)
colnames(m1.c)[8] = "e11.listener.p"
performance.output[3, ] = c("m1.c", round(cor(m1.c$listener.p, m1.c$pred), 5),
                            round(cor(m1.c$e11.listener.p, m1.c$pred), 5), T)
# Store plot
m1.c.plot = qplot(stars, listener.p, col=degree, 
      data=m1.c,
      main=paste("m1.c\nalpha: ", alphas[3],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[3, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 1.d)
# Entailment only
# Normalized = F
# alpha tune = T
alphas[4] = tune.alpha(data.partial, normalize=F)
m1.d = data.partial %>%
  do(run.partial(., alpha = alphas[4], useprior=T, usenone=F, normalize=F))
# Store output
m1.d = cbind(m1.d, data.full.transfer$listener.p)
colnames(m1.d)[8] = "e11.listener.p"
performance.output[4, ] = c("m1.d", round(cor(m1.d$listener.p, m1.d$pred), 5),
                            round(cor(m1.d$e11.listener.p, m1.d$pred), 5), normalized=F)
# Store plot
m1.d.plot = qplot(stars, listener.p, col=degree, 
      data=m1.d,
      main=paste("m1.d\nalpha: ", alphas[4],
                 "\nNormalized = ", F,
                 "\nCorr = ", performance.output[4, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# Model 2 - Entailment + generic none
# --------------------------------
# 2.a)
# Entailment + generic None
# Normalized = T
# alpha tuning = F
alphas[5] = 1
m2.a = data.partial %>%
  do(run.partial(., alpha = alphas[5], useprior=T, usenone=T, normalize=T))
# Store output
m2.a = cbind(m2.a, data.full.transfer$listener.p)
colnames(m2.a)[8] = "e11.listener.p"
performance.output[5, ] = c("m2.a", round(cor(m2.a$listener.p, m2.a$pred), 5),
                            round(cor(m2.a$e11.listener.p, m2.a$pred), 5), T)
# Store plot
m2.a.plot = qplot(stars, listener.p, col=degree, 
      data=m2.a,
      main=paste("m2.a\nalpha: ", alphas[5],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[5, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 2.b)
# Entailment + generic None
# Normalized = F
# alpha tune = F
alphas[6] = 1
m2.b = data.partial %>%
  do(run.partial(., alpha = alphas[6], useprior=T, usenone=T, normalize=F))
# Store output
m2.b = cbind(m2.b, data.full.transfer$listener.p)
colnames(m2.b)[8] = "e11.listener.p"
performance.output[6, ] = c("m2.b", round(cor(m2.b$listener.p, m2.b$pred), 5),
                            round(cor(m2.b$e11.listener.p, m2.b$pred), 5), F)
# Store plot
m2.b.plot = qplot(stars, listener.p, col=degree, 
      data=m2.b,
      main=paste("m2.b\nalpha: ", alphas[6],
                 "\nNormalized = ", F,
                 "\nCorr = ", performance.output[6, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 2.c)
# Entailment + generic None
# Normalized = T
# alpha tune = T
# compare.data = Toggle this with data.full.transfer for e11 or NULL for e6
alphas[7] = tune.alpha(data.partial, normalize=T, compare.data=NULL)
m2.c = data.partial %>%
  do(run.partial(., alpha = alphas[7], useprior=T, usenone=T, normalize=T))
# Store output
m2.c = cbind(m2.c, data.full.transfer$listener.p)
colnames(m2.c)[8] = "e11.listener.p"
performance.output[7, ] = c("m2.c", round(cor(m2.c$listener.p, m2.c$pred), 5),
                            round(cor(m2.c$e11.listener.p, m2.c$pred), 5), T)
# Store plot
m2.c.plot = qplot(stars, listener.p, col=degree, 
      data=m2.c,
      main=paste("m2.c\nalpha: ", alphas[7],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[7, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 2.d)
# Entailment + generic None
# Normalized = F
# alpha tune = T
# compare.data = Toggle this with data.full.transfer for e11 or NULL for e6
alphas[8] = tune.alpha(data.partial, normalize=F)
m2.d = data.partial %>%
  do(run.partial(., alpha = alphas[8], useprior=T, usenone=T, normalize=F))
# Store output
m2.d = cbind(m2.d, data.full.transfer$listener.p)
colnames(m2.d)[8] = "e11.listener.p"
performance.output[8, ] = c("m2.d", round(cor(m2.d$listener.p, m2.d$pred), 5),
                            round(cor(m2.d$e11.listener.p, m2.d$pred), 5), F)
# Store plot
m2.d.plot = qplot(stars, listener.p, col=degree, 
      data=m2.d,
      main=paste("m2.d\nalpha: ", alphas[8],
                 "\nNormalized = ", F,
                 "\nCorr = ", performance.output[8, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# Model 3 - Empirical alternatives
# --------------------------------
# 3.a)
# Emp alts
# Normalized = T
# alpha tuning = F
alphas[9] = 1
m3.a = data.full %>%
  do(run.full(., alpha = alphas[9], addMid=F, normalize=T))
# Match with e6 w/ checks
m3.a.matched = m3.a[matched.items, ]
m3.a.matched$degree = ifelse(m3.a.matched$degree == "hi1", "hi", "low")
m3.a.matched = cbind(m3.a.matched, data.partial$listener.p)
all(m3.a.matched$scale == data.partial$scale & m3.a.matched$degree == data.partial$degree)

## [1] TRUE

colnames(m3.a.matched)[length(colnames(m3.a.matched))] = "e6.listener.p"
# Store output
performance.output[9, ] = c("m3.a", round(cor(m3.a.matched$e6.listener.p, m3.a.matched$pred), 5),
                            round(cor(m3.a.matched$listener.p, m3.a.matched$pred), 5), T)
# Store plot
m3.a.plot = qplot(stars, e6.listener.p, col=degree, 
      data=m3.a.matched,
      main=paste("m3.a\nalpha: ", alphas[9],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[9, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 3.b)
# Emp alts
# Entailment + generic None
# Normalized = F
# alpha tune = F
alphas[10] = 1
m3.b = data.full %>%
  do(run.full(., alpha = alphas[10], addMid=F, normalize=F))
# Match with e6 w/ checks
m3.b.matched = m3.b[matched.items, ]
m3.b.matched$degree = ifelse(m3.b.matched$degree == "hi1", "hi", "low")
m3.b.matched = cbind(m3.b.matched, data.partial$listener.p)
all(m3.b.matched$scale == data.partial$scale & m3.b.matched$degree == data.partial$degree)

## [1] TRUE

colnames(m3.b.matched)[length(colnames(m3.b.matched))] = "e6.listener.p"
# Store output
performance.output[10, ] = c("m3.b", round(cor(m3.b.matched$e6.listener.p, m3.b.matched$pred), 5),
                             round(cor(m3.b.matched$listener.p, m3.b.matched$pred), 5), F)
# Store plot
m3.b.plot = qplot(stars, e6.listener.p, col=degree, 
      data=m3.b.matched,
      main=paste("m3.b\nalpha: ", alphas[10],
                 "\nNormalized = ", F,
                 "\nCorr = ", performance.output[10, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 3.c)
# Emp alts
# Normalized = T
# alpha tune = T
# compare.data = Toggle this with data.partial for e6 or NULL for e11
alphas[11] = tune.alpha(data.full, type = "full", compare.data=data.partial, addMid=F, normalize=T)
m3.c = data.full %>%
  do(run.full(., alpha = alphas[11], addMid=F, normalize=T))
# Match with e6 w/ checks
m3.c.matched = m3.c[matched.items, ]
m3.c.matched$degree = ifelse(m3.c.matched$degree == "hi1", "hi", "low")
m3.c.matched = cbind(m3.c.matched, data.partial$listener.p)
all(m3.c.matched$scale == data.partial$scale & m3.c.matched$degree == data.partial$degree)

## [1] TRUE

colnames(m3.c.matched)[length(colnames(m3.c.matched))] = "e6.listener.p"
# Store output
performance.output[11, ] = c("m3.c", round(cor(m3.c.matched$e6.listener.p, m3.c.matched$pred), 5),
                             round(cor(m3.c.matched$listener.p, m3.c.matched$pred), 5), T)

# Store plot 2 - both e6 and e11 data
m3.c.jointD = m3.c.matched %>%
  gather(study, listener.pred, listener.p, e6.listener.p)
m3.c.jointD$study = ifelse(m3.c.jointD$study == "e6.listener.p", "e6", "e11")
m3.c.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
      data=m3.c.jointD,
      main=paste("m3.c\nalpha: ", alphas[11],
                 "\nNormalized = ", T,
                 ylab="Posterior p(rating | word)")) +
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 3.d)
# Emp alts
# Normalized = F
# alpha tune = T
# compare.data = Toggle this with data.partial or NULL
alphas[12] = tune.alpha(data.full, type = "full", compare.data=data.partial, addMid=F, normalize=F)
m3.d = data.full %>%
  do(run.full(., alpha = alphas[12], addMid=F, normalize=F))
# Match with e6 w/ checks
m3.d.matched = m3.d[matched.items, ]
m3.d.matched$degree = ifelse(m3.d.matched$degree == "hi1", "hi", "low")
m3.d.matched = cbind(m3.d.matched, data.partial$listener.p)
all(m3.d.matched$scale == data.partial$scale & m3.d.matched$degree == data.partial$degree)

## [1] TRUE

colnames(m3.d.matched)[length(colnames(m3.d.matched))] = "e6.listener.p"
# Store output
performance.output[12, ] = c("m3.d", round(cor(m3.d.matched$e6.listener.p, m3.d.matched$pred), 5),
                             round(cor(m3.d.matched$listener.p, m3.d.matched$pred), 5), F)

# Store plot 2 - both e6 and e11 data
m3.d.jointD = m3.d.matched %>%
  gather(study, listener.pred, listener.p, e6.listener.p)
m3.d.jointD$study = ifelse(m3.d.jointD$study == "e6.listener.p", "e6", "e11")
m3.d.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
      data=m3.d.jointD,
      main=paste("m3.d\nalpha: ", alphas[12],
                 "\nNormalized = ", T,
                 ylab="Posterior p(rating | word)")) +
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# Model 4 - Empirical alternatives + extras
# -----------------------------------------
# 4.a)
# Emp alts + extras
# Normalized = T
# alpha tuning = F
alphas[13] = 1
m4.a = data.full.extras %>%
  do(run.full(., alpha = alphas[13], addMid=T, normalize=T))
# Match with e6 w/ checks
m4.a.matched = m4.a[matched.items.extras, ]
m4.a.matched$degree = ifelse(m4.a.matched$degree == "hi1", "hi", "low")
m4.a.matched = cbind(m4.a.matched, data.partial$listener.p)
all(m4.a.matched$scale == data.partial$scale & m4.a.matched$degree == data.partial$degree)

## [1] TRUE

colnames(m4.a.matched)[length(colnames(m4.a.matched))] = "e6.listener.p"
# Store output
performance.output[13, ] = c("m4.a", round(cor(m4.a.matched$e6.listener.p, m4.a.matched$pred), 5), 
                             round(cor(m4.a.matched$listener.p, m4.a.matched$pred), 5), T)
# Store plot
m4.a.plot = qplot(stars, e6.listener.p, col=degree, 
      data=m4.a.matched,
      main=paste("m4.a\nalpha: ", alphas[13],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[13, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 4.b)
# Emp alts + extras
# Normalized = F
# alpha tune = F
alphas[14] = 1
m4.b = data.full.extras %>%
  do(run.full(., alpha = alphas[14], addMid=T, normalize=F))
# Match with e6 w/ checks
m4.b.matched = m4.b[matched.items.extras, ]
m4.b.matched$degree = ifelse(m4.b.matched$degree == "hi1", "hi", "low")
m4.b.matched = cbind(m4.b.matched, data.partial$listener.p)
all(m4.b.matched$scale == data.partial$scale & m4.b.matched$degree == data.partial$degree)

## [1] TRUE

colnames(m4.b.matched)[length(colnames(m4.b.matched))] = "e6.listener.p"
# Store output
performance.output[14, ] = c("m4.b", round(cor(m4.b.matched$e6.listener.p, m4.b.matched$pred), 5), 
                             round(cor(m4.b.matched$listener.p, m4.b.matched$pred), 5), F)
# Store plot
m4.b.plot = qplot(stars, e6.listener.p, col=degree, 
      data=m4.b.matched,
      main=paste("m4.b\nalpha: ", alphas[14],
                 "\nNormalized = ", F,
                 "\nCorr = ", performance.output[14, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 4.c)
# Emp alts + extras
# Normalized = T
# alpha tune = T
# compare.data = Toggle this with data.partial or NULL
alphas[15] = tune.alpha(data.full.extras, type = "full", compare.data=data.partial, addMid=T, normalize=T)
m4.c = data.full.extras %>%
  do(run.full(., alpha = alphas[15], addMid=T, normalize=T))
# Match with e6 w/ checks
m4.c.matched = m4.c[matched.items.extras, ]
m4.c.matched$degree = ifelse(m4.c.matched$degree == "hi1", "hi", "low")
m4.c.matched = cbind(m4.c.matched, data.partial$listener.p)
all(m4.c.matched$scale == data.partial$scale & m4.c.matched$degree == data.partial$degree)

## [1] TRUE

colnames(m4.c.matched)[length(colnames(m4.c.matched))] = "e6.listener.p"
# Store output (e11 and e6)
performance.output[15, ] = c("m4.c", round(cor(m4.c.matched$e6.listener.p, m4.c.matched$pred), 5),
                             round(cor(m4.c.matched$listener.p, m4.c.matched$pred), 5), T)

# Store plot 2 - both e6 and e11 data
m4.c.jointD = m4.c.matched %>%
  gather(study, listener.pred, listener.p, e6.listener.p)
m4.c.jointD$study = ifelse(m4.c.jointD$study == "e6.listener.p", "e6", "e11")
m4.c.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
      data=m4.c.jointD,
      main=paste("m4.c\nalpha: ", alphas[15],
                 "\nNormalized = ", T,
                 ylab="Posterior p(rating | word)")) +
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)


# 4.d)
# Emp alts + extras
# Normalized = F
# alpha tune = T
# compare.data = Toggle this with data.partial or NULL
alphas[16] = tune.alpha(data.full.extras, type = "full", compare.data=data.partial, addMid=T, normalize=F)
m4.d = data.full.extras %>%
  do(run.full(., alpha = alphas[16], addMid=T, normalize=F))
# Match with e6 w/ checks
m4.d.matched = m4.d[matched.items.extras, ]
m4.d.matched$degree = ifelse(m4.d.matched$degree == "hi1", "hi", "low")
m4.d.matched = cbind(m4.d.matched, data.partial$listener.p)
all(m4.d.matched$scale == data.partial$scale & m4.d.matched$degree == data.partial$degree)

## [1] TRUE

colnames(m4.d.matched)[length(colnames(m4.d.matched))] = "e6.listener.p"
# Store output
performance.output[16, ] = c("m4.d", round(cor(m4.d.matched$e6.listener.p, m4.d.matched$pred), 5),
                             round(cor(m4.d.matched$listener.p, m4.d.matched$pred), 5), F)

# Store plot 2 - both e6 and e11 data
m4.d.jointD = m4.d.matched %>%
  gather(study, listener.pred, listener.p, e6.listener.p)
m4.d.jointD$study = ifelse(m4.d.jointD$study == "e6.listener.p", "e6", "e11")
m4.d.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
      data=m4.d.jointD,
      main=paste("m4.d\nalpha: ", alphas[16],
                 "\nNormalized = ", T,
                 ylab="Posterior p(rating | word)")) +
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

Discussion

Interpreting the output table:

m1: Entailment only models (i.e. “some_all” scale only includes “some”, “all”)

m2: Entailment + generic None models (i.e. “some_all” scale includes “none”, “some”, “all”)

m3: Full model with empirical alternatives (i.e. “some_all” scale includes “none”, “some”, “most”, all“)

m4: Entailment + empirical alternatives + additional fitted scalar (i.e. “some_all” scale includes “none”, “some”, “mid”, “most”, all“)

a: Normalized literal listener values before running RSA, no alpha tuning

b: No normalization for literal listener values before running RSA, no alpha tuning

c: Normalized literal listener values before running RSA, alpha tuning

d: No normalization for literal listener values before running RSA, alpha tuning

performance.output$cor.e6 = as.numeric(performance.output$cor.e6)
performance.output$cor.e11 = as.numeric(performance.output$cor.e11)
performance.output = performance.output %>%
  mutate(avg.corr =
           (cor.e6 + cor.e11) / 2)
performance.output = cbind(performance.output, alphas)
# reorder columns
performance.output = performance.output[, c(1, 2, 3, 5, 4, 6)]
grid.table(performance.output)

Initial thoughts:

Overall

Across e6 and e11 pragmatic listener judgements we see model fit improve as we add more alternatives. The largest improvement in model fit occurs when we first include the empirically derived salient alternatives (correlations jump +0.23). Have a look at the m2 vs m3 correlation for models with pre-RSA normalization below (c models):

# Tuned, normalized models r
barchart.d = performance.output[c(3, 7, 11, 15), ] %>%
  gather(study, cor, cor.e6, cor.e11)
barchart.d$cor = as.numeric(barchart.d$cor)
ggplot(barchart.d, aes(x=model, y=cor, fill=study)) + 
  geom_bar(stat="identity", position="dodge") +
  ylim(0, 1) + 
  ggtitle("Model fit for e6 and e11\npragmatic listener judgments") +
  geom_text(aes(x=model, y=as.numeric(cor) + 0.025, label=round(cor, 3), col=(study)))

Here’s another look at the improvement in model fit between normalized m2 and m3.

m2.c.plot

m3.c.jointPlot

Importantly, we also see improvements with the addition of ‘fitted’ alternatives in m4 see the plots below:

m3.c.jointPlot

m4.c.jointPlot

This presents a little bit more of a challenge, however, as we’d like to jointly fit our alpha as well as our alternatives - is this worth delving into? Currently we’re just fitting alpha and then finding alternatives.

Additional notes:

1. In general model performance is greater (correlation) for e11 data. This may be due in part to less extreme literal listener evaluations in e11 see:

https://cdn.rawgit.com/langcog/scalar_implicature/master/models/RSA%2BAmbiguousSemantics.html#pragmatic-listener-studies—judgement-distributional-differences

Our best model performance occurs with e11 and the model is m4.c, correlation = 0.93492 (see plot below):

qplot(stars, listener.p, col=degree, 
      data=m4.c.matched,
      main=paste("m4.c\nalpha: ", alphas[15],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[15, 3]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

Normalizing vs not normalizing before running RSA:

Non-normalized models seem to be more sensitive to alpha tuning as the number of alternatives increases (see m4.d and m3.d with alpha = 8). I’m not sure if there is a theoretical consideration here that RSA may want to address? What does it mean to normalize literal listener values prior to computing the posterior? One repercussion is that during normalization we’ll see larger impact from salient alternatives… In Model_addtionalAlts.Rmd I’m seeing that higher entropy scales memorable_unforgettable, palatable_delicious appear to be looking for more alternatives (correlation improves when I add wacky distributions such as [0, 0.1, 0.9, 0.1, 0.9] which suggests that we need possibly two more alternatives, not just one). This seems intuitive in the higher entropy setting… Can we interpret this kind of finding (at least intuitively) as the model telling us it wants more alternatives? See

https://cdn.rawgit.com/langcog/scalar_implicature/master/models/Model_additionalAlts.html#match-items-between-studies-full-and-partial

All plots with e6 prag judgements

m1.a.plot

m1.b.plot

m1.c.plot

m1.d.plot

m2.a.plot

m2.b.plot

m2.c.plot

m2.d.plot

m3.a.plot

m3.b.plot

m3.c.jointPlot

m3.d.jointPlot

m4.a.plot

m4.b.plot

m4.c.jointPlot

m4.d.jointPlot

Other exploration

# bad.predictions = m3.fit.matched$pred > 0 &
#                   m3.fit.matched$e6.listener.p == 0 &
#                   (m3.fit.matched$pred - m3.fit.matched$e6.listener.p > 0.05)